Ham Radio 2000 #1/Ham Radio 2000.iso/ham2000/misc/worldmap/mapvu20/mapview.pas

Pascal/Delphi Source File | 1989-01-11 | 45.5 KB | 1,314 lines

Program mapview; { program to view worldmap }
{ See MAPVIEW.DOC for complete documentation                                 }

{ Copyright A.J. van den Bogert and Gisbert W.Selke Jan 1989                 }

{$UNDEF  DEBUG }                       { DEFINE while debugging }

{$IFDEF DEBUG }
{$A+,R+,S+,I+,D+,F-,V-,B-,L+ }      { turn checking on while debugging }
{$ELSE }
{$A+,R-,S-,I+,D-,F-,V-,B-,L+ }
{$ENDIF }
{$M 65500,65500,560000}

{$IFDEF CPU87 }
{$N+ }
{$ELSE }
{$N- }
{$ENDIF }

Uses Crt, Dos, Graph, mapgraph, mapproj;

Const deflstext   = '.LST';     { default extension for list files }
      defcmdext   = '.CMD';     { default extension for command files }
      defpicext   = '.PIC';     { default extension for screen save files }
      confname   ='MAPVIEW.CNF';{ configuration file name }
      defpicname  ='SCREEN.PIC';{ default screen save file }
      deflstname  = 'EMPTY.LST';{ default list file }
      helpname   ='MAPVIEW.HLP';{ help file }
      {$IFOPT N+ }
      trigname    = 'TRIG3.BIN';{ precomputed trig values }
      {$ELSE }
      trigname    = 'TRIG2.BIN';{ precomputed trig values }
      {$ENDIF }
      defprinter  = 1;          { default printer port }
      defaspcorr  = 1.0;        { default aspect ratio correction }
      defbgcolour =   0;        { default background colour }
      defgrcolour = -99;        { default grid       colour }
      defbrcolour =  99;        { default border     colour }
      defnrep     =   1;        { default number of overprintings }
      noreal1     = 9999.9;     { dummy value }
      noreal2     = 9999.0;     { ditto }
      maxmpdir    = 15;         { maximum number of MPx default subdirs }
      {$IFOPT N+ }
      mpsize     =   25;        { size of a MP3 record - assumes 4-byte-reals }
      mpmaxrec   = 1480;        { MP3 buffer array size   }
      {$ELSE }
      mpsize     =   37;        { size of a MP2 record - assumes 6-byte-reals }
      mpmaxrec   = 1000;        { MP2 buffer array size   }
      {$ENDIF }
      mp0size     =  4;         { size of a MP0 record - assumes 2-byte-ints  }
      mp0maxrec   =  9250;      { MP0 buffer array size   }
      { The following equation must hold:                 }
      { mpsize*mpmaxrec = mp0size*mp0maxrec }
      banner    : string[11] = 'MAPVIEW 2.0';
      copyright : string[9]  = 'Copyright';
      author    : string[68] =
     'A.J. van den Bogert, TapirSoft Gisbert W.Selke 08 Jan 1989';

Type mprec = Record
               rectyp : byte;      { Record type: 1 is start of segment }
               lon, lat : real;  { longitude and latitude }
               merclat : real;   { Mercator function of latitude }
               xg, yg, zg : real;{ globe coordinates }
             End;
     mp0rec = Record
                ilon, ilat : integer; { shifted lon/lat values }
              End;
     dirstr = string[63];
     ftypes = (mpjunk, mp, mp0, mp1);

{$IFOPT N+ }
Const mpext : Array [ftypes] Of string = ('.???', '.MP3', '.MP0', '.MP1');
{$ELSE }
Const mpext : Array [ftypes] Of string = ('.???', '.MP2', '.MP0', '.MP1');
{$ENDIF }

Var

{ INTERNAL USER-MODIFIABLE PARAMETERS:  }
 screenfile : scrfile;
 filename : string;                     { name of map file }
 screenfilename : string;               { name of screen dump file }
 printer : byte;                        { number of printer port }
 gridlon, gridlat : real;               { grid intervals }
 grid : boolean;                        { show grid? }
 interact : boolean;                    { interactive or no?}
 autoadapt : boolean;                   { always fill entire screen? }
 showcmdline : boolean;                 { show command line? }
 quit : boolean;                        { should we quit? }
 userfinish : boolean;                  { user intervention? }
 cmddir : dirstr;                       { default CMD file subdirectory }
 lstdir : dirstr;                       { default LST file subdirectory }
 picdir : dirstr;                       { default PIC file subdirectory }
 mpdir : Array [1..maxmpdir] Of dirstr; { list of default MPx subdirectories }
 mpdirct : byte;                        { number of MPx subdirectories }

{ CONFIGURABLE PARAMETERS }

 aspcorr  : real;                       { aspect ratio correction }
 grcolour : integer;                    { grid colour }
 brcolour : integer;                    { border colour }
 bgcolour : word;                       { background colour }
 nrep     : byte;                       { number of overprintings for hardcopy }

{ HIDDEN PARAMETERS }
 inlin : string;                        { buffer for user input }
 linptr : integer;                      { buffer pointer }
 isnextreal, screenfileopen, directmp,  washeaperror : boolean;
                                        { internal flags }
 exitsave : pointer;                    { exit procedure pointer }

{ WORKING VARIABLES }
mpfile : File;
mp1file : text;
filetype : ftypes;
mpbuf  : Array [1..mpmaxrec] Of mprec;
mp0buf : Array [1..mp0maxrec] Of mp0rec Absolute mpbuf; { share memory loc }
currec, maxrec : word;
finish : boolean;
nextreal, getpointx, getpointy : real;

{****** LOW LEVEL ROUTINES ******}

Procedure strip(Var lin : string);
{ strip leading and trailing blanks; convert to uppercase, too               }
  Var i : byte;
Begin                                                                { strip }
  While (Length(lin) > 0) And (lin[1] = ' ') Do Delete(lin,1,1);
  While (Length(lin) > 0) And (lin[Length(lin)] = ' ') Do
                                               Delete(lin,Length(lin),1);
  For i := 1 To Length(lin) Do lin[i] := UpCase(lin[i]);
End;                                                                 { strip }

Function decomp(angle : real) : string;
{ decompose angle into degrees, minutes and seconds of arc; return as string }
  Var rminu : real;
      tempint : integer;
      tempstr, res : string;
Begin                                                               { decomp }
  tempint := Trunc(angle);
  str(tempint,res);
  rminu:= 60.0 * Abs(angle - tempint);
  tempint := Trunc(rminu);
  str(tempint,tempstr);
  If tempint < 10 Then tempstr := '0' + tempstr;
  res := res + ':' + tempstr;
  tempint := Round(60.0*(rminu- tempint));
  str(tempint,tempstr);
  If tempint < 10 Then tempstr := '0' + tempstr;
  decomp := res + ':' + tempstr;
End;                                                                { decomp }

Function prepend(ds, fs : string) : string;
{ prepend a directory string to a file name                                  }
Begin                                                              { prepend }
  If Pos(':',fs) > 0 Then Delete(fs,1,Pos(':',fs));
  While (fs <> '') And (Pos('\',fs) > 0) Do Delete(fs,1,Pos('\',fs));
  prepend := ds + fs;
End;                                                               { prepend }

Function hasext(t : string) : boolean;
{ check if given file name has an extension included                         }
Begin                                                               { hasext }
  While Pos('\',t) > 0 Do Delete(t,1,Pos('\',t));
  hasext := Pos('.',t) > 0;
End;                                                                { hasext }

Procedure more;
{ DOS-like more prompt on text screen; sets userfinish True if Q, ESC, CTRL-C}
  Var ch : char;
Begin                                                                 { more }
  GoToXY(50,25);
  write('Hit any key to continue... ');
  ch := UpCase(ReadKey);
  userfinish := (ch = 'Q') Or (ch = ctrlc) Or (ch = esc);
End;                                                                  { more }

Function getstring : string;
{ extract blank-terminated string from input buffer                          }
  Var lt, ct : byte;
Begin                                                            { getstring }
  lt := Length(inlin);
  While (linptr <= lt) And (inlin[linptr] = ' ') Do Inc(linptr);
  ct := 1;
  While (linptr+ct <= lt) And (inlin[linptr+ct] <> ' ') Do Inc(ct);
  getstring := Copy(inlin,linptr,ct);
  linptr := linptr + ct;
End;                                                             { getstring }

Function instring(Var t : string; maxlg : byte) : boolean;
{ either read a string from the kbd or extract it from line buffer           }
Begin                                                             { instring }
  If interact Then instring := intext(t,maxlg)
  Else Begin
    t := getstring;
    If Length(t) > maxlg Then delete(t,Succ(maxlg),255);
    instring := True;
  End;
End;                                                              { instring }

Function getrealbuff : real;
{ extract blank-terminated real from input buffer                            }
  Var tmp, tmp2 : real;
      code, code2 : integer;
      ipos : byte;
      minus : boolean;
      t : string;
Begin                                                          { getrealbuff }
  getrealbuff := noreal1;
  t := getstring;
  If t <> '' Then
  Begin
    ipos := Pos(':',t);
    If ipos = 0 Then Val(t,tmp,code)
    Else
    Begin { read dd:mm:ss form; first a sign, if any, then dd: }
      minus := t[1] = '-';
      If minus Then
      Begin
        Delete(t,1,1);
        Dec(ipos);
      End;
      Val(Copy(t,1,Pred(ipos)),tmp,code);
      Delete(t,1,ipos);
      If t <> '' Then
      Begin { now mm }
        ipos := Pos(':',t);
        If ipos = 0 Then
        Begin
          Val(t,tmp2,code2);
          tmp := tmp + tmp2/60.0;
          code := code + code2;
        End Else
        Begin
          Val(Copy(t,1,Pred(ipos)),tmp2,code2);
          tmp := tmp + tmp2/60.0;
          code := code + code2;
          Delete(t,1,ipos);
          If t <> '' Then
          Begin  { now ss, possibly with decimals }
            Val(t,tmp2,code2);
            tmp := tmp + tmp2/3600.0;
            code := code + code2;
          End;
        End;
      End;
      If minus Then tmp := -tmp;
    End;
    If code = 0 Then getrealbuff := tmp
                Else errmsg('ERROR: real number expected');
  End;
End;                                                           { getrealbuff }

Function getreal : real;
{ get a real number, either interactively (as typed or via crosshair) or     }
{ from input buffer, if read from batch                                      }
  Var y, xa, ya : real;
      dummy, firstin : boolean;
Begin                                                              { getreal }
  isnextreal := False;
  If interact Then
  Begin
    If intext(inlin,15) Then
    Begin
      inlin := inlin + ' ';
      linptr := 1;
      y := getrealbuff;
    End Else
    Begin
      xa := getpointx;
      ya := getpointy;
      firstin := True;
      getpoint(xa,ya,dummy,firstin,True);
      invproject(xa,ya,nextreal,y);
      If nextreal > noreal1 Then nextreal := noreal1;
      isnextreal := True;
    End;
  End Else y := getrealbuff;
  If y <= noreal1 Then getreal := y Else getreal := noreal1;
End;                                                               { getreal }

Function getnextreal : real;
{ get 2nd real number of a coordinate pair                                   }
Begin                                                          { getnextreal }
  If isnextreal Then getnextreal := nextreal
                Else getnextreal := getreal;
End;                                                           { getnextreal }

Function testlstfile(Var filnam : string) : boolean;
{ open a lst file; set filetype accordingly, and indicate success          }
  Var dummylf : file;
      ext : string;
      ierr : word;
Begin                                                          { testlstfile }
  ext := filnam;
  While Pos('.',ext) > 0 Do Delete(ext,1,Pos('.',ext));
  If Copy(ext,1,2) = 'MP' Then testlstfile := False
  Else
  Begin
    Assign(dummylf,filnam);
    {$I- } Reset(dummylf); {$I+ }
    ierr := IOResult;
    If (ierr <> 0) And (lstdir <> '') Then
    Begin
      Assign(dummylf,prepend(lstdir,filnam));
      {$I- } Reset(dummylf); {$I+ }
      ierr := IOResult;
      If ierr = 0 Then filnam := prepend(lstdir,filnam);
    End;
    If ierr = 0 Then Close(dummylf);
    testlstfile := ierr = 0;
  End;
End;                                                           { testlstfile }

Function openmpfile(filnam : string) : boolean;
{ open a map file; set filetype accordingly, and indicate success            }
  Var ft : ftypes;
      ts : string;

  Function foundfile(Var fs : string) : boolean;
  { try to find file in various subdirectories                               }
    Var dummymf : file;
        i : byte;
  Begin                                                          { foundfile }
    Assign(dummymf,fs);
    {$I- } Reset(dummymf); {$I+ }
    If IOResult = 0 Then
    Begin
      Close(dummymf);
      foundfile := True;
      Exit;
    End;
    If (Pos(':',fs) = 0) And (Pos('\',fs) = 0) Then
    Begin
      For i := 1 To mpdirct Do
      Begin
        Assign(dummymf,prepend(mpdir[i],fs));
        {$I- } Reset(dummymf); {$I+ }
        If IOresult = 0 Then
        Begin
          Close(dummymf);
          foundfile := True;
          fs := prepend(mpdir[i],fs);
          Exit;
        End;
      End;
    End;
    foundfile := False;
  End;                                                           { foundfile }

Begin                                                           { openmpfile }
  If hasext(filnam) Then
  Begin
    ts := Copy(filnam,Pos('.',filnam),4);
    filetype := mpjunk;
    For ft := mp To mp1 Do If ts = mpext[ft] Then filetype := ft;
    Case filetype Of
      mpjunk : Begin
                 errmsg('Illegal map file extension ' + filnam);
                 openmpfile := False;
               End;
      mp  : Begin
              If foundfile(filnam) Then
              Begin
                Assign(mpfile,filnam);
                reset(mpfile,mpsize);
                openmpfile := True;
              End Else openmpfile := False;
            End;
      mp0 : Begin
              If foundfile(filnam) Then
              Begin
                Assign(mpfile,filnam);
                reset(mpfile,mp0size);
                openmpfile := True;
              End Else openmpfile := False;
            End;
      mp1 : Begin
              If foundfile(filnam) Then
              Begin
                Assign(mp1file,filnam);
                reset(mp1file);
                SetTextBuf(mp1file,mpbuf);
                openmpfile := True;
              End Else openmpfile := False;
            End;
    End;
  End Else
  Begin
    If openmpfile(filnam+mpext[mp]) Then openmpfile := True
      Else If openmpfile(filnam+mpext[mp0]) Then openmpfile := True
        Else If openmpfile(filnam+mpext[mp1]) Then openmpfile := True
          Else openmpfile := False;
  End;
End;                                                            { openmpfile }

Procedure getbin(Var binbuf : mprec);
{ read a set of coordinates; preprocess adequately, if necessary             }
Begin                                                               { getbin }
  If filetype = mp Then
  Begin
    If currec >= maxrec Then
    Begin
      BlockRead(mpfile,mpbuf,mpmaxrec,maxrec);
      currec := 0;
    End;
    finish := maxrec = 0;
    Inc(currec);
    If Not finish Then binbuf := mpbuf[currec];
  End Else
  Begin
    With binbuf Do
    Begin
      If filetype = mp0 Then
      Begin
        If currec >= maxrec Then
        Begin
          BlockRead(mpfile,mp0buf,mp0maxrec,maxrec);
          currec := 0;
        End;
        finish := maxrec = 0;
        Inc(currec);
        If Not finish Then
        Begin
          With mp0buf[currec] Do
          Begin
            lon := ilon * 0.01;
            If ilat < 20000 Then
            Begin
              lat := ilat * 0.01;
              rectyp := 0;
            End Else
            Begin
              lat := (ilat - 20000) * 0.01;
              rectyp := 1;
            End;
          End;
        End;
      End Else
      Begin
        rectyp := currec;       { kludge to get rectyp 1 on 1st record, }
        currec := 0;            { i.e., start new outline               }
        Repeat
          finish := eof(mp1file);
          If Not finish Then readln(mp1file,inlin);
          strip(inlin);
          If inlin = '' Then rectyp := 1;
        Until (inlin <> '') Or finish;
        If finish Then
        Begin
          lat := noreal1;
          lon := noreal1;
        End Else
        Begin
          linptr := 1;
          lat := getrealbuff;
          lon := getrealbuff;
        End;
      End;
      Case projtype Of
        mercator, lambert : merclat := mercproj(lat);
        ortho :    orthoproj(lon,lat,xg,yg,zg);
        Else ;
      End;
    End;
  End;
End;                                                                { getbin }

Procedure closempfile;
{ close the appropriate map data file                                        }
Begin                                                          { closempfile }
  Case filetype Of
    mp, mp0 : close(mpfile);
    mp1 : close(mp1file);
  End;
End;                                                           { closempfile }

Procedure openscreenfile(temp : string);
{ if screen save file exists, open for append; if not, create it             }
  Var picd : picdesc;
      ios : word;
Begin                                                       { openscreenfile }
  If screenfileopen Then Close(screenfile);
  screenfileopen := False;
  Assign(screenfile,temp);
  {$I- } Reset(screenfile,1); {$I+ }
  If IOResult = 0 Then
  Begin
    BlockRead(screenfile,picd,SizeOf(picd),ios);
    If ios = 0 Then screenfileopen := True
    Else Begin
      If (ios <> SizeOf(picd)) Or (picd.grdriver <> thisgraphdriver) Then
                          errmsg('File ' + temp + ' has illegal format')
      Else Begin
        Seek(screenfile,FileSize(screenfile));
        screenfileopen := True;
      End;
    End
  End Else
  Begin
    {$I- } Rewrite(screenfile,1); {$I+ }
    If IOResult = 0 Then screenfileopen := True
                 Else errmsg('Cannot open file ' + temp + ' for screen saves');
  End;
  If screenfileopen Then screenfilename := temp;
End;                                                        { openscreenfile }

{$F+ } Function heaperrorfunc(size : word) : integer; {$F- }
{ catch heap allocation errors, try to free memory, else return Nil pointer  }
Begin                                                        { heaperrorfunc }
  If fasttrig Then
  Begin
    dispotrigs;
    heaperrorfunc := 2;
  End
  Else
  Begin
    heaperrorfunc := 1;
    washeaperror := True;
  End;
End;                                                         { heaperrorfunc }

{****** BASIC GRAPHICS ROUTINES ******}

Procedure showdir(mask : string);
{ show DOS file directory                                                    }
  Var sr : SearchRec;
      ct : word;
Begin                                                              { showdir }
  ct := 0;
  FindFirst(mask,ReadOnly+Hidden+Archive,sr);
  While DosError = 0 Do
  Begin
    write(sr.Name:15,'   ');
    Inc(ct);
    If (ct Mod 4) = 0 Then writeln;
    FindNext(sr);
  End;
  writeln;
End;                                                               { showdir }

Procedure showprompt;
{ display a prompt, unless ...                                               }
Begin                                                           { showprompt }
  If showcmdline Then prompt('/ /a/c/d/e/g/h/l/m/n/p/q/s/w/x/z (? For help):')
                 Else unprompt;
End;                                                            { showprompt }


{****** USER COMMANDS ******}

Procedure drawmap;
{ draw map using current parameter settings                                  }

  Var savcolour : word;
      savlatmin, savlatmax : real;
      itemp : longint;
      ierr : integer;
      listfile : text;
      filnam, temp: string;
      savshowcmdline : boolean;

 Procedure adjustlat;
 { temporarily adjust latitude extremes                                      }
 Begin                                                           { adjustlat }
   savlatmin := latmin; savlatmax := latmax;
   If projtype = mercator Then
   Begin
     latmin := rmax(latmin,-85.0);
     latmax := rmin(latmax, 85.0);
   End;
   If Abs(latmax-latmin) < epsilon Then latmax := latmax + 1.0;
 End;                                                            { adjustlat }

  Procedure getminmax(Var mylonmin, mylatmin, mylonmax, mylatmax : real);
  { if MP0 or MP  file, find out which region this map covers                }
    Var binbuf : mprec;
  Begin                                                          { getminmax }
    Case filetype Of
      MP0 : Begin
              getbin(binbuf);
              mylonmin := binbuf.lon;
              mylatmin := binbuf.lat;
              getbin(binbuf);
              mylonmax := binbuf.lon;
              mylatmax := binbuf.lat;
            End;
      MP1 : Begin
              mylonmin := -180.0;
              mylatmin :=  -90.0;
              mylonmax :=  180.0;
              mylatmax :=   90.0;
            End;
      MP  : Begin
              getbin(binbuf);
              mylonmin := binbuf.lon;
              mylatmin := binbuf.lat;
              mylonmax := binbuf.merclat;
              mylatmax := binbuf.xg;
            End;
    End;
  End;                                                           { getminmax }

  Procedure drawonemap;
  { draw a single map file                                                   }
    Var ct : byte;
        xo, yo, xn, yn : integer;
        vis1, vis2 : boolean;
        x2, y2, z2, dist, alpha, mylonmin, mylatmin, mylonmax, mylatmax : real;
        binbuf : mprec;
  Begin                                                         { drawonemap }
    SetColor(colourglb);
    ct := 0;
    currec := 1; { kludge for MP1 files; cf getbin above }
    If Not openmpfile(filnam) Then
    Begin
      errmsg('Map file ' + filnam + ' not found');
      Exit;
    End;
    maxrec := 1; currec := 2;
    getminmax(mylonmin,mylatmin,mylonmax,mylatmax);
    If (mylonmin <= lonmax) And (mylonmax >= lonmin) And
       (mylatmin <= latmax) And (mylatmax >= latmin) Then
    Begin
      getbin(binbuf);
      While Not finish Do
      Begin
        Inc(ct);  { occasional overflow is what we want! }
        With binbuf Do Begin
          vis2 := (lon < lonmax) And (lon > lonmin) And
                  (lat < latmax) And (lat > latmin);
          If vis2 Then
          Begin
            x2 := 0.0; y2 := 0.0;
            Case projtype Of
              none :      Begin
                            x2 := lon;
                            y2 := lat;
                          End;
              mercator :  Begin
                            vis2 := Abs(lat) <= 85.0;
                            If vis2 Then
                            Begin
                              x2 := lon;
                              y2 := merclat;
                            End;
                          End;
              ortho :     Begin
                            orthorot(xg,yg,zg,x2,y2,z2);
                            vis2 := z2 > -epsilon;
                          End;
              lambert  : lambproj(lon,merclat,x2,y2);
              azinorth : aziproj(lon,lat,x2,y2);
              azisouth : aziproj(180.0-lon,-lat,x2,y2);
              Else     project(lon,lat,x2,y2);  { for future extensions }
            End; { Case }
            xn := scalex(x2); yn := scaley(y2);
            If (rectyp = 0) And vis1 And vis2 Then Line(xo,yo,xn,yn);
          End;
        End; { With }
        If (ct = 0) And savshowcmdline Then showprogress(1);
        xo := xn; yo := yn;
        vis1 := vis2;
        userfinish := checkuser;
        getbin(binbuf);
        finish := finish Or userfinish;
      End;
    End;
    closempfile;
    finish := userfinish;
    SetColor(White);
  End;                                                          { drawonemap }

Begin                                                              { drawmap }
  savshowcmdline := showcmdline;
  showcmdline := False;
  showprompt;
  If savshowcmdline Then showprogress(0);
  checkwindow;
  adjustlat;
  mapborder(brcolour,savshowcmdline);
  If grid Then drawgrid(gridlon,gridlat,grcolour,savshowcmdline);
  If Not directmp Then
  Begin
    If Not testlstfile(filename) Then
    Begin
      errmsg('List file ' + filename + ' not found');
      Exit;
    End;
    Assign(listfile,filename);
    {$I- } reset(listfile); {$I+ }
    finish := eof(listfile);
  End Else finish := False;
  While Not finish Do
  Begin
    savcolour := colourglb;
    If directmp Then filnam := filename
    Else Begin
      readln(listfile,inlin);
      strip(inlin);
      linptr := 1;
      filnam := getstring;
      finish := filnam = 'END';
      If (Not finish) And (filnam <> '') And (filnam[1] <> ';') Then
      Begin
        temp := getstring;
        If temp <> '' Then
        Begin
          {$R- } Val(temp,itemp,ierr); {$IFDEF DEBUG } {$R+ } {$ENDIF }
          If (ierr = 0) And (itemp >= 0) And (itemp <= maxcolour) Then
                                                          colourglb := itemp;
        End;
      End;
    End;
    drawonemap;
    colourglb := savcolour;
    If directmp Then finish := True
                Else finish := finish Or eof(listfile);
  End; { While }
  If Not directmp Then Close(listfile);
  latmin := savlatmin; latmax := savlatmax;
  If (interact) Then
  Begin
    Sound(440);
    Delay(200);
    NoSound;
  End;
  If savshowcmdline Then showprogress(2);
  showcmdline := savshowcmdline;
End;                                                               { drawmap }

Procedure coordinates;
{ display coordinates of selected point                                      }
  Var x, y : real;
      lat, lon : real;
      finish, firstin : boolean;
Begin                                                          { coordinates }
  lon := (lonmin + lonmax) * 0.5;
  lat := (latmin + latmax) * 0.5;
  firstin := True;
  project(lon,lat,x,y);
  prompt('Latitude: ' + decomp(lat) + ' / Longitude: ' + decomp(lon));
  Repeat
    If Not KeyPressed Then
    Begin
      invproject(x,y,lon,lat);
      prompt('Latitude: ' + decomp(lat) + ' / Longitude: ' + decomp(lon));
    End;
    getpoint(x,y,finish,firstin,False);
  Until finish;
  unprompt;
End;                                                           { coordinates }

Procedure setgrid;
{ set grid intervals or toggle grid display                                  }
  Var x : real;
Begin                                                              { setgrid }
  If interact Then prompt('Enter latitude interval:');
  x := getreal;
  If x >= noreal2 Then grid := Not grid Else
  Begin
    If x >= 1.0 Then gridlat := x;
    If interact Then prompt('Enter longitude interval:');
    x := getnextreal;
    If x > 1.0 Then gridlon := x;
    unprompt;
    grid := True;
  End;
End;                                                               { setgrid }

Procedure status;
{ display mode settings                                                      }
  Var i : byte;
      palette : palettetype;
Begin                                                               { status }
  preservescreen;
  RestoreCRTMode;
  write(banner);
  {$IFOPT N+ }
  writeln(' (coprocessor version)');
  {$ELSE }
  writeln(' (non-coprocessor version)');
  {$ENDIF }
  writeln;
  write('Projection: ');
  Case projtype Of
    none     : writeln('None');
    mercator : writeln('Mercator');
    ortho    : writeln('Orthographic;  midpoint (lat/lon): ',
                       decomp(midlat),'/',decomp(midlon));
    lambert  : writeln('Lambert (conformal conical);  midpoint (lat/lon): ',
                       decomp(midlat),'/',decomp(midlon));
    azinorth : writeln('Azimuthal area preserving (north)');
    azisouth : writeln('Azimuthal area preserving (south)');
  End;
  writeln('Window (lat/lon): ',decomp(latmin),'/',
          decomp(lonmin),' .. ',decomp(latmax),'/',decomp(lonmax));
  write('Grid intervals (lat/lon): ',decomp(gridlat),'/',decomp(gridlon));
  If grid Then writeln(' (on)') Else writeln(' (off)');
  write('Adaptive scaling ');
  If autoadapt Then writeln('on') Else writeln('off');
  If directmp Then writeln('Map file         : ',filename)
              Else writeln('List of map files: ',filename);
  writeln('Screen file      : ',screenfilename);
  If fasttrig Then write('U') Else write('Not u');
  writeln('sing fast trig table');
  writeln;
  GetPalette(palette);
  With palette Do
  Begin
    If size > 1 Then
    Begin
      write('Colour palette:');
      For i := 0 To Pred(size) Do write(' ',colors[i]);
      writeln;
    End;
  End;
  writeln('Current colours are (available: 0..',maxcolour,'):');
  writeln('drawing: ',colourglb,'; grid: ',grcolour,'; border: ',brcolour,
          '; background: ',bgcolour);
  writeln;
  writeln('Printer port     : ',printer,'; overprintings: ',nrep);
  writeln;
  writeln('Directories used for');
  write('command files: current');
  If cmddir <> '' Then write(', ',cmddir);
  writeln;
  write('   list files: current');
  If lstdir <> '' Then write(', ',lstdir);
  writeln;
  write('picture files: current');
  If picdir <> '' Then write(', ',picdir);
  writeln;
  write('    map files: current');
  For i := 1 To mpdirct Do
  Begin
    write(', ');
    If WhereX + Length(mpdir[i]) > 77 Then
    Begin
      writeln;
      write(' ':15);
    End;
    write(mpdir[i]);
  End;
  writeln;
  more;
  restorescreen;
End;                                                                { status }

Procedure help;
{ display help screen                                                        }
  Var helpf : text;
      helpline : string;
Begin                                                                 { help }
  preservescreen;
  RestoreCRTMode;
  Assign(helpf,helpname);
  {$I- } Reset(helpf); {$I+ }
  If IOResult <> 0 Then
    writeln('Help file ',helpname,' not found. You''re on your own.')
  Else Begin
    userfinish := False;
    While Not (EoF(helpf) Or userfinish) Do
    Begin
      If WhereY = 25 Then
      Begin
        more;
        ClrScr;
      End;
      readln(helpf,helpline);
      If Not userfinish Then writeln(helpline);
    End;
    Close(helpf);
  End;
  If Not userfinish Then more;
  restorescreen;
End;                                                                  { help }

Procedure setprojection;
{ set projection method and its parameters, if applicable                    }
  Var xtemp : real;
      temp : string;
Begin                                                        { setprojection }
  If interact Then prompt('Enter projection type (None, Mercator, ' +
                          'Azimuthal, Orthographic, Lambert):');
  Repeat Until instring(temp,1);
  If temp = '' Then temp := ' ';
  temp[1] := UpCase(temp[1]);
  Case temp[1] Of
    ' ',#13 : ; { ignore }
    'N' : Begin
            setprojtype(none);
            If autoadapt Then adaptscale;
          End;
    'M' : Begin
            setprojtype(mercator);
            If autoadapt Then adaptscale;
          End;
    'O' : Begin
            If interact Then prompt('Enter midpoint of latitude:');
            xtemp := getreal;
            If xtemp <= noreal2 Then
            Begin
              midlat := xtemp;
              If interact Then prompt('Enter midpoint of longitude:');
              xtemp := getnextreal;
              If xtemp <= noreal2 Then midlon := xtemp;
            End;
            unprompt;
            { calculate matrix elements }
            setprojtype(ortho);
          End;
    'L' : Begin
            If interact Then prompt('Enter midpoint of latitude:');
            xtemp := getreal;
            If xtemp <= noreal2 Then
            Begin
              midlat := xtemp;
              If interact Then prompt('Enter midpoint of longitude:');
              xtemp := getnextreal;
              If xtemp <= noreal2 Then midlon := xtemp;
            End;
            unprompt;
            setprojtype(lambert);
          End;
    'A' : setprojtype(azinorth);
    Else errmsg('ERROR: unknown projection type');
  End;
End;                                                         { setprojection }

Procedure setcol;
{ set colour for drawing                                                     }
  Var temp : string;
      itemp : longint;
      ierr : integer;
Begin                                                               { setcol }
  If interact Then prompt('Enter number of colour for subsequent plotting:');
  Repeat Until instring(temp,2);
  If temp <> '' Then
  Begin
    {$R- } Val(temp,itemp,ierr); {$IFDEF DEBUG } {$R+ } {$ENDIF }
    If (ierr=0) And (itemp>=0) And (itemp<=maxcolour) Then colourglb := itemp
                                                 Else errmsg('Illegal value');
  End;
End;                                                                { setcol }

Procedure setwindow;
{ set map window                                                             }
  Var xtemp : real;
Begin                                                            { setwindow }
  If interact Then
           prompt('Enter South West corner (latitude, or use cursor keys):');
  project((2*lonmin+lonmax)/3,(2*latmin+latmax)/3,getpointx,getpointy);
  xtemp := getreal;
  If xtemp <= noreal2 Then
  Begin
    latmin := xtemp;
    If interact Then prompt('Enter South West corner (longitude):');
    xtemp := getnextreal;
    If xtemp <= noreal2 Then lonmin := xtemp;
  End;
  If interact Then
          prompt('Enter North East corner (latitude, or use cursor keys):');
  project((lonmin+2*lonmax)/3,(latmin+2*latmax)/3,getpointx,getpointy);
  xtemp := getreal;
  If xtemp <= noreal2 Then
  Begin
    latmax := xtemp;
    If interact Then prompt('Enter North East corner (longitude):');
    xtemp := getnextreal;
    If xtemp <= noreal2 Then lonmax := xtemp;
  End;
  If autoadapt Then adaptscale;
  If (projtype = azinorth) Or (projtype = azisouth) Then setprojtype(projtype);
End;                                                             { setwindow }

Procedure setfilelist;
{ set file from which to read map file names                                 }
  Var temp : string;
      extgiven : boolean;
      namlgt : byte;
Begin                                                          { setfilelist }
  Repeat
    If interact Then prompt('File name (? For available files):');
    Repeat Until instring(temp,63);
    unprompt;
    If temp = '?' Then
    Begin
      preservescreen;
      RestoreCRTMode;
      writeln('Available list files:');
      showdir('*'+deflstext);
      If lstdir <> '' Then showdir(lstdir+'*'+deflstext);
      more;
      restorescreen;
    End;
  Until temp <> '?';
  strip(temp);
  If temp <> '' Then
  Begin
    extgiven := hasext(temp);
    namlgt := Length(temp);
    If Not extgiven Then temp := temp + deflstext;
    If testlstfile(temp) Then
    Begin
      filename := temp;
      directmp := False;
    End Else
    Begin
      prompt('List file ' + temp + ' not found');
      Delay(1000);
      prompt('Trying to find a corresponding map file...');
      Delay(1000);
      If Not extgiven Then Delete(temp,Succ(namlgt),255);
      If openmpfile(temp) Then
      Begin
        directmp := True;
        filename := temp;
      End Else
      Begin
        prompt('No file ' + temp + ' found');
        Delay(1000);
      End;
    End;
  End;
End;                                                           { setfilelist }

Procedure setscreenfile;
{ set file for screen saves                                                  }
  Var temp : string;
Begin                                                        { setscreenfile }
  If interact Then prompt('Enter name of file to save screens to:');
  Repeat Until instring(temp,63);
  unprompt;
  strip(temp);
  If (temp <> '') Then
  Begin
    If Pos('.',temp) = 0 Then temp := temp + defpicext;
    If (Pos(':',temp) = 0) And (Pos('\',temp) = 0) Then temp := picdir + temp;
    openscreenfile(temp);
  End;
End;                                                         { setscreenfile }

Procedure savetofile;
{ handle screen file save                                                    }
Begin                                                           { savetofile }
  If Not screenfileopen Then openscreenfile(screenfilename);
  If screenfileopen Then save(screenfile);
End;                                                            { savetofile }

Procedure docommand;
{ do a single command                                                        }
  Var cmd : char;

  Procedure execute;
  { execute file with commands                                               }
    Var savinteract : boolean;
        filnam, temp : string;
        cmdfile : text;
        ierr : word;
  Begin                                                            { execute }
    Repeat
      If interact Then
               prompt('Enter name of command file (? For available files):');
      Repeat Until instring(temp,63);
      unprompt;
      If temp = '?' Then
      Begin
        preservescreen;
        RestoreCRTMode;
        writeln('Available command files:');
        showdir('*'+defcmdext);
        If cmddir <> '' Then showdir(cmddir+'*'+defcmdext);
        more;
        restorescreen;
      End;
    Until temp <> '?';
    If temp <> '' Then
    Begin
      filnam := temp;
      If Pos('.',filnam) = 0 Then filnam := filnam + defcmdext;
      strip(filnam);
      Assign(cmdfile,filnam);
      {$I- } Reset(cmdfile); {$I+ }
      ierr := IOResult;
      If (ierr <> 0) And (cmddir <> '') Then
      Begin
        Assign(cmdfile,prepend(cmddir,filnam));
        {$I- } Reset(cmdfile); {$I+ }
        ierr := IOResult;
      End;
      If ierr <> 0 Then errmsg('Command file ' + filnam + ' not found')
      Else
      Begin
        savinteract := interact;
        interact := False;
        userfinish := False;
        While Not (eof(cmdfile) Or userfinish) Do
        Begin
          readln(cmdfile,inlin);
          docommand;
          userfinish := checkuser;
        End;
        Close(cmdfile);
        interact := savinteract;
      End;
    End;
  End;                                                             { execute }

Begin                                                            { docommand }
  inlin := ConCat(inlin,' ');
  linptr := 1;
  cmd := UpCase(inlin[linptr]);
  Inc(linptr);
  Case cmd Of
    '?' : help;
    ' ' : Begin showcmdline := Not showcmdline; showprompt; End;
    'A' : Begin autoadapt := Not autoadapt; If autoadapt Then adaptscale; End;
    'C' : setcol;
    'D' : drawmap;
    'E' : erasescreen;
    'G' : setgrid;
    'H' : Begin unprompt; scrprint(printer,nrep); End;
    'L' : setfilelist;
    'M' : status;
    'N' : setscreenfile;
    'P' : setprojection;
    'S' : savetofile;
    'W' : coordinates;
    'X' : execute;
    'Z' : setwindow;
    'Q', ctrlc, esc : If interact Then
                            quit := confirmquit('Do you really want to quit?')
                        Else quit := True;
    ';' : ;   { comment indicator in command files }
    #13 : ;   { ignore CR }
    Else errmsg('ERROR: unknown command');
  End;
End;                                                             { docommand }

{$F+ } Procedure exitmapview; {$F- }
{ make sure we close graphics down, even in case of a runtime error          }
Begin                                                          { exitmapview }
  ExitProc := exitsave;
  If screenfileopen Then Close(screenfile);
  leavegraphic;
  If fasttrig Then dispotrigs;
  If washeaperror Then writeln('Not enough memory to run MapView properly');
  writeln(banner,'  --  ',author);
  writeln; writeln('Thanks for calling.');
End;                                                           { exitmapview }

Procedure initall;
{ set initial values of user parameters                                      }

  Procedure readconf;
  { try to find .CNF file; if found, extract default info                    }
    Const maxpre = 12;
          availpre : Array [1..maxpre] Of string[3] =
    ('CMD','LST','PIC','MPX','MOD','ASP','GRC','BRC','BGC','PAL','OVP','PRN');
    Var cnf : text;
        palette : palettetype;
        i, npre : byte;
        pre : string;
        t : integer;
        t1 : shortint;
        tr : real;

    Function checkdir(t : string) : string;
    { make sure it's a valid directory string                                }
    Begin                                                         { checkdir }
      Delete(t,63,255);
      If t[Length(t)] <> '\' Then t := t + '\';
      checkdir := t;
    End;                                                          { checkdir }

  Begin                                                           { readconf }
    mpdirct := 0;
    cmddir := '';
    lstdir := '';
    picdir := '';
    Assign(cnf,confname);
    {$I- } Reset(cnf); {$I+ }
    If IOResult = 0 Then
    Begin
      While Not eof(cnf) Do
      Begin
        readln(cnf,inlin);
        strip(inlin);
        linptr := 1;
        pre := getstring;
        linptr := 4;
        npre := 0;
        For i := 1 To maxpre Do If pre = availpre[i] Then npre := i;
        If pre[1] = ';' Then npre := 99;
        Case npre Of
          0 : errmsg('Illegal specification ' + pre +
                     ' in configuration file');
         99 : ; { comment line }
          1 : cmddir := checkdir(getstring);
          2 : lstdir := checkdir(getstring);
          3 : picdir := checkdir(getstring);
          4 : Begin  { map files directories }
                If mpdirct < maxmpdir Then
                Begin
                  Inc(mpdirct);
                  mpdir[mpdirct] := checkdir(getstring);
                End Else errmsg('Too many MPX lines in configuration file');
              End;
          5 : Begin  { non-standard graphics mode }
                newgraphmode(Round(getrealbuff));
              End;
          6 : Begin  { aspect ratio correction for non-standard screens }
                tr := getrealbuff;
                If (tr > 0.0) And (tr <= noreal2) Then aspcorr := tr;
              End;
          7 : grcolour := Round(getrealbuff);   { grid colour }
          8 : brcolour := Round(getrealbuff);   { border colour }
          9 : bgcolour := Round(getrealbuff);   { background colour }
         10 : Begin  { set colour palette }
                t := Round(getrealbuff);
                tr := getrealbuff;
                If (Round(tr) >= -127) And (Round(tr) <= 127)
                  Then t1 := Round(tr) Else tr := 127;
                GetPalette(palette);
                If (t1 >= 0) And (t1 <= maxcolour) And (t >= 0) And
                                 (t  <= palette.size) Then SetPalette(t,t1);
              End;
         11 : Begin  { set number of overprintings for hardcopy }
                t := Round(getrealbuff);
                If (t > 0) And (t <= 10) Then nrep := t;
              End;
         12 : Begin  { set number of printer port }
                t := Round(getrealbuff);
                If (t >= 1) And (t <= 4) Then printer := t;
              End;
        End;
      End;
      Close(cnf);
    End;
  End;                                                            { readconf }

Begin                                                              { initall }
  HeapError:= @heaperrorfunc;
  washeaperror := False;
  fasttrig     := False;
  exitsave := ExitProc;
  ExitProc := @exitmapview;
  initgraphic;
  If washeaperror Then Halt(1);
  printer  := defprinter;
  aspcorr  := defaspcorr;
  grcolour := defgrcolour;
  brcolour := defbrcolour;
  bgcolour := defbgcolour;
  nrep     := defnrep;
  readconf;
  readtrigs(trigname);
  washeaperror := False;
  If Abs(grcolour) > maxcolour Then grcolour := isignum(grcolour) * maxcolour;
  If Abs(brcolour) > maxcolour Then brcolour := isignum(brcolour) * maxcolour;
  If bgcolour > maxcolour Then bgcolour := maxcolour;
  If bgcolour < 0    Then bgcolour := 0;
  aspect := aspect * aspcorr;
  SetBkColor(bgcolour);
  filename := deflstname;
  screenfilename := picdir + defpicname;
  gridlon  := 20.0;
  gridlat  := 20.0;
 { set internal parameters }
  directmp := False;
  isnextreal := False;
  grid     := True;
  showcmdline := True;
  interact := True;
  autoadapt:= False;
  screenfileopen := False;
  quit     := False;
End;                                                               { initall }

{ ****** MAIN PROGRAM ****** }
Begin                                                                 { main }
  {$IFDEF DEBUG }
    CheckBreak := True;
  {$ELSE }
    CheckBreak := False;
  {$ENDIF }
  initall;
  logo(banner,author);
  delay(2000);
  unprompt;
  mapborder(brcolour,False);
  drawgrid(gridlon,gridlat,grcolour,False);
  If ParamCount > 0 Then
  Begin
    inlin := 'X ' + ParamStr(1);
    interact := False;
    userfinish := False;
    docommand;
    interact := True;
  End;
  While Not quit Do
  Begin
    showprompt;
    inlin := '*';
    inlin[1] := ReadKey;
    unprompt;
    userfinish := False;
    docommand;
  End;
  { all closing stuff is done in exitmapview }
End.                                                                  { main }